home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / a_utils / perl / jinx.lha / jinx.pl < prev    next >
Text File  |  1993-08-13  |  19KB  |  681 lines
  1.  
  2. # jinx.pl -- Copyright (c) 1990, Henk P. Penning.
  3. # You may distribute under the terms of the GNU General Public License
  4. # as specified in the README file that comes with the Jinx 2.1 kit.
  5.  
  6. # addlog()
  7. # is redefined in jinx to do something useful
  8. sub addlog { ; }
  9.  
  10. # min(@row)
  11. # returns smallest of @row
  12. sub min
  13.   { return(undef) if $#_ < 0 ;
  14.     local($res) = shift ; for ( @_ ) { $res = $_ if $_ < $res ; }
  15.     return($res) ;
  16.   }
  17.  
  18. # max(@row)
  19. # returns greatest element of @row
  20. sub max
  21.   { return(undef) if $#_ < 0 ;
  22.     local($res) = shift ; for ( @_ ) { $res = $_ if $_ > $res ; }
  23.     return($res) ;
  24.   }
  25.  
  26. # maxStrlen(*row,$from,$to)
  27. # returns length of longest string in @row[$from..$to]
  28. sub maxStrlen
  29.   { local(*row,$from,$to) = @_ ;
  30.     local($res,$len,$i) ;
  31.     $to = &min($to,$#row) ;
  32.     for ($i=$from ; $i <= $to ; $i++ )
  33.       { $len = length($row[$i]) ;
  34.         $res = $len if $len > $res ;
  35.       }
  36.     return($res) ;
  37.   }
  38.  
  39. # tailstr($str,$from)
  40. # returns substr($str,$from)
  41. # still here for compatibility with pre pl41 perls
  42. sub tailstr
  43.   { local($str,$from) = @_ ;
  44.     local($l) = length($str) ;
  45.     if ( $from > $l - 1)
  46.       { return('') ; }
  47.     else
  48.       { return(substr($str,$from,$l-$from)) ; }
  49.   }
  50.  
  51. # extint($str)
  52. # translates $str from EXTernal to INTernal format
  53. # substitutes $; for ":" except for the escaped ":" 
  54. # removes escapes for ":" and "!" in user data
  55. sub extint
  56.   { local($_) = @_ ;
  57.     local($res,$pref) ;
  58.     while ( /!(.)/ )
  59.       { $pref = $` ;
  60.     { $pref =~ s/:/$;/g ; }
  61.         $res .= ( $pref . $1 ) ;
  62.     $_ = $' ;
  63.       }
  64.     s/:/$;/g ;
  65.     $res .= $_ ;
  66.     return $res ;
  67.   }
  68.  
  69. # intext($str)
  70. # translates $str from INTernal to EXTernal format
  71. # escapes ":" and "!" in user data
  72. # substitutes ":" for $;
  73. sub intext
  74.   { local($_) = @_ ;
  75.     s/!/!!/g ;
  76.     s/:/!:/g ;
  77.     s/$;/:/g ;
  78.     return $_ ;
  79.   }
  80.  
  81. # getInfo(*info,$db,$suff)
  82. # reads file "$db.$suff" into @info in internal format
  83. # returns 1 iff sucsesful
  84. sub getInfo
  85.   { local(*info,$db,$suff) = @_ ;
  86.     local($_) ;
  87.     if ( open(INFO,"$db.$suff") )
  88.       { &addlog("opened $db.$suff") ; }
  89.     else
  90.       { return(0) ; }
  91.     @info = <INFO> ;
  92.     chop @info ;
  93.     for ( @info )
  94.       { $_ = &extint($_) ; }
  95.     close(INFO) ;
  96.     &addlog("closed $db.$suff") ;
  97.     return(1) ;
  98.   }
  99.  
  100. # putInfo(*info,$db,$suff)
  101. # moves file "$db.$suff" (if any) to "$db.$suff.save" 
  102. # writes file "$db.$suff" with contents of @info in external format
  103. # returns pair (1 iff successful, some-informative-message)
  104. sub putInfo
  105.   { local(*info,$db,$suff) = @_ ;
  106.     local($_,$save) = 0 ;
  107.  
  108.     $save = -e "$db.$suff" ;
  109.  
  110.     return(0,"no write permission for $db.$suff")
  111.       if $save && ! -w "$db.$suff" ;
  112.  
  113.     if ( $save && ! rename("$db.$suff","$db.$suff.save") )
  114.       {  return(0,"cannot rename $db.$suff") ; }
  115.  
  116.     if ( ! open(DATA,">$db.$suff") )
  117.       { if ( $save && ! rename("$db.$suff.save","$db.$suff") )
  118.           { return(0,"error but old $suff in $db.$suff.save") ; }
  119.         return(0,"cannot open $db.$suff for writing") ;
  120.       }
  121.  
  122.     for ( @info )
  123.       { if ( ! print DATA &intext($_), "\n" )
  124.           { close(DATA) ;
  125.             if ( $save && ! rename("$db.$suff.save","$db.$suff") )
  126.               { return(0,"error but old $suff in $db.$suff.save") ; }
  127.             return(0,"cannot write everything to $db.$suff") ;
  128.           }
  129.       }
  130.     close(DATA) ;
  131.  
  132.     &addlog("saved $db.$suff") ;
  133.     return(1, "$db.$suff " . ($save ? "saved" : "created") ) ;
  134.   }
  135.  
  136. # emptyRecord($size)
  137. # returns an array @res such that $#a == $size
  138. # I guess I don't trust fooling around with $# too much
  139. sub emptyRecord
  140.   { local($size) = @_ ;
  141.     local(@res) ;
  142.     for (local($i) ; $i<=$size ; $i++ )
  143.       { push(@res,'') ; }
  144.     return @res ;
  145.   }
  146.  
  147. # addFieldNP(*descr,*name,$nam,*cpat,$pat)
  148. # adds a fieldname $name and pattern $pat to a descriptor @descr,
  149. # and name- and pattern-list
  150. sub addFieldNP
  151.   { local(*descr,*name,$nam,*cpat,$pat) = @_ ;
  152.     push(@descr,"name$;" . ( $#name + 2 ) . "$;$nam") ;
  153.     push(@descr,"cpat$;" . ( $#cpat + 2 ) . "$;$pat") ;
  154.     push(@name,$nam) ;
  155.     push(@cpat,$pat) ;
  156.   }
  157.  
  158. # mkDescr(*descr,*name,*cpat)
  159. # creates a descriptor @descriptor from a name- and pattern-list
  160. sub mkDescr
  161.   { local(*descr,*name,*cpat) = @_ ;
  162.     local($i) = 1 ;
  163.     @descr =  () ;
  164.     for ( @name )
  165.       { push(@descr,"name$;$i$;" . $name[$i-1]) ;
  166.         push(@descr,"cpat$;$i$;" . $cpat[$i-1]) ;
  167.     $i++ ;
  168.       }
  169.   }
  170.  
  171. # splitDescr(*descr,*name,*cpat)
  172. # assumes a correct descriptor in @descriptor
  173. # creates a name- and pattern-list from a @descriptor
  174. sub splitDescr
  175.   { local(*descr,*name,*cpat) = @_ ;
  176.     local(@tmp,$d) ;
  177.     @name = () ;
  178.     @cpat = () ;
  179.     for $d ( @descr )
  180.       { @tmp = split(/$;/,$d,3) ;
  181.     if ( $tmp[0] eq 'name' )
  182.           { $name[$tmp[1]-1] = $tmp[2] ; }
  183.     elsif ( $tmp[0] eq 'cpat' )
  184.       { $cpat[$tmp[1]-1] = $tmp[2] ; }
  185.       }
  186.    $#cpat = $#name ;
  187.   }
  188.  
  189. # splitNewDescr(*descr,*name,*cpat)
  190. # creates a name- and pattern-list from a @descriptor
  191. # assumes nothing, returns a list of errors found
  192. sub splitNewDescr
  193.   { local(*descr,*name,*cpat) = @_ ;
  194.     local(@errors,@tmp,$d) ;
  195.     @name = () ;
  196.     @cpat = () ;
  197.     for $d ( @descr )
  198.       { @tmp = split(/$;/,$d) ;
  199.     if ( $#tmp < 1 )
  200.       { push(@errors,"wrong number of fields in " . &intext($d) ) ; }
  201.     elsif ( $tmp[1] !~ /^[1-9][0-9]*$/ )
  202.       { push(@errors,"no field number in " . &intext($d) ) ; }
  203.     elsif ( $tmp[0] eq 'name' )
  204.           { $name[$tmp[1]-1] = $tmp[2] ; }
  205.     elsif ( $tmp[0] eq 'cpat' )
  206.       { $cpat[$tmp[1]-1] = $tmp[2] ; }
  207.       }
  208.     return @errors ;
  209.   }
  210.  
  211. # checkDescrName(*name)
  212. # checks if a name list @name is correct, that is
  213. # all names are unique, none-empty, alphanumeric strings
  214. # assumes nothing, returns a list of errors found
  215. sub checkDescrName
  216.   { local(*name) = @_ ;
  217.     local(@res,$key,%names,$_) ;
  218.     for ( @name )
  219.       { $names{$_}++ ; }
  220.     for (keys %names)
  221.       { if ( $names{$_} != 1 )
  222.           { push(@res,"name $_ used $names{$_} times") ; }
  223.     if ( $_ eq '' )
  224.           { push(@res,"empty name used $names{$_} time(s)") ; }
  225.     if ( $_ !~ /$namePat/ )
  226.           { push(@res,"$names{$_} not alpha-numeric") ; }
  227.       }
  228.     return @res  ;
  229.   }
  230.  
  231. # checkDescr(*name)
  232. # checks if a name- and pattern-list are correct, that is
  233. # all names are unique, none-empty, alphanumeric strings
  234. # all patterns are valid regexp's, no more patterns than names
  235. # assumes nothing, returns a list of errors found
  236. sub checkDescr
  237.   { local(*name,*pat) = @_ ;
  238.     local(@res) = &checkDescrName(*name) ;
  239.     local($i,$pat) ;
  240.     for $pat ( @pat )
  241.       { if ( ! &testPat($pat) )
  242.           { push(@res,"$@ for $name[$i]") ; }
  243.     $i++ ;
  244.       }
  245.     push(@res,'more patterns than names') if $#pat > $#name ;
  246.     while ( $#pat < $#name ) { push(@pat,'') ; }
  247.     return @res ;
  248.   }
  249.  
  250. # cleanData()
  251. # makes sure all strings in @data, if split on $;,
  252. # produce an array with $# == $size
  253. # clobbers excess data, sorry
  254. sub cleanData
  255.   { local(*data,$size) = @_ ;
  256.     local($d,@values) ;
  257.     for $d ( @data )
  258.       { @values = split(/$;/,$d,$size+2) ;
  259.         if ( $#values == $size )
  260.           { next ; }
  261.         elsif ( $#values < $size )
  262.           { $values[$size] = '' ; }
  263.         else # ( $#values > $size )
  264.           { $#values = $size ; }
  265.         $d = join($;,@values) ;
  266.       }
  267.   }
  268.  
  269. # openDb($str,*descr,*data,*name,*pat)
  270. # opens database $str
  271. # sets descriptor @descr and data @data
  272. # sets namelist @name and patternlist @pat
  273. # returns pair (status,some-informative-message)
  274. # success : status == 0
  275. # fail    : status == 1 implies descriptor found but no data-file
  276. # fail    : status == 2 implies semantic errors in descriptor
  277. # fail    : status == 3 implies syntactic errors in descriptor
  278. # fail    : status == 4 implies $str eq ''
  279. # doesn't clobber arguments if some error is found
  280. # makes sure each record in @data contains the right number of fields
  281. sub openDb
  282.   { local($str,*descr,*data,*name,*pat) = @_ ;
  283.  
  284.     local(@errors,@tmpDescr,@tmpName,@tmpPat,@tmpData) ;
  285.  
  286.     return(4,'no name ; no change') if $str eq '' ;
  287.  
  288.     if ( ! &getInfo(*tmpDescr,$str,'des') )
  289.       { return 3, "cannot open $str.des ; no change" ; }
  290.  
  291.     @errors = &splitNewDescr(*tmpDescr,*tmpName,*tmpPat) ;
  292.     if ( $#errors >= 0 )
  293.       { return(2,"syn errors in $str.des",@errors,'no change') ; }
  294.     @errors = &checkDescr(*tmpName,*tmpPat) ;
  295.     if ( $#errors >= 0 )
  296.       { return(2,"sem errors in $str.des",@errors,'no change') ; }
  297.  
  298.     if ( ! &getInfo(*tmpData,$str,'dat') )
  299.       { return(1,"cannot open $str.dat ; no change") ; }
  300.  
  301.     @descr = @tmpDescr ;
  302.     @name  = @tmpName ;
  303.     @pat   = @tmpPat ;
  304.     @data  = @tmpData ;
  305.  
  306.     &cleanData(*data,$#name) ;
  307.     return(0,"opened $str") ;
  308. }
  309.  
  310. # openCurrDb($str)
  311. # jinx-private
  312. sub openCurrDb
  313.   { local($str) = @_ ;
  314.     local($res,@errors) ;
  315.  
  316.     ($res,@errors) = &openDb($str,*descr,*data,*name,*pat) ;
  317.     return(0,@errors) if $res > 1 ;
  318.  
  319.     $db = $str ;
  320.     return(1,@errors) ;
  321. }
  322.  
  323. # testPat($pat)
  324. # returns 1 iff $pat is a valid regexp
  325. # modifies $@ a little if an error is found
  326. sub testPat
  327.   { local($pat) = shift ;
  328.     eval("/\$pat/;") ;
  329.     if ( $@ )
  330.       { $@ =~ s/regexp at.*/pattern/ ;
  331.         $@ =~ s/(.*) in file.*/$1/ ;
  332.         chop $@ while $@ =~ /\n$/ ;
  333.         return(0);
  334.       }
  335.     return(1);
  336.   }
  337.  
  338. # testExpr($expr)
  339. # returns 1 iff $expr is a valid perl expression
  340. # modifies $@ a little if an error is found
  341. sub testExpr
  342.   { local($expr) = shift ;
  343.     local(@errors) ;
  344.     eval("package AAP ; do { $expr ; }\n") ;
  345.     if ( $@ )
  346.       { $@ = (split(/\n/,$@))[0] ;
  347.         return(0);
  348.       }
  349.     return(1);
  350.   }
  351.  
  352. # mkInvert(*row)
  353. # uses @row (index->value) to create the inverse %row (value->index)
  354. # such that: @row{@row} = 0..$#row
  355. # all values in @row should be uniq (for instance a namelist)
  356. sub mkInvert
  357.   { local(*row) = @_ ;
  358.     local($i,$_) ;
  359.     %row = undef ;
  360.     $i = '0' ;
  361.     for ( @row )
  362.       { $row{$_} = $i++ ; }
  363.   }
  364.  
  365. # doTest(*record,*pat)
  366. # tests for all $i in 0..$#record : $record[$i] matches $pat[$i]
  367. # returns the list of indexes for which a mismatch was found
  368. sub doTest
  369.   { local(*record,*pat) = @_ ;
  370.     local($_,@res,$i) ;
  371.     for ( @record )
  372.       { if ( $pat[$i] && ! /$pat[$i]/ )
  373.       { push(@res,$i) ; } ;
  374.     $i++ ;
  375.       }
  376.     return @res ;
  377.   }
  378.  
  379. sub byNum { $a - $b ; }
  380.  
  381. # multiSort(*data,*sortKey)
  382. # each element of @data is a $;-separated list of fields
  383. # @sortKey is a non-empty list of sortKeys
  384. # sorts @data such that
  385. # field sortKey[0] is used as primary key,
  386. # field sortKey[1] is used as secundary key etc
  387. # sorts keys as strings
  388. sub multiSort
  389.   { local(*data,*sortKey) = @_ ;
  390.     local($i,%msort,$_) = 0 ;
  391.     for ( @data ) { $msort{join($;,(split(/$;/))[@sortKey])} .= $i++ . ',' ; }
  392.     @data = @data[split(/,/,join('',@msort{sort keys %msort}))] ;
  393.   }
  394.  
  395. # doSort(*data,*sortKey)
  396. # same as multiSort above except that @sortKey may be empty
  397. # in which case a 'plain' sort is done
  398. sub doSort
  399.   { local(*data,*sortKey) = @_ ;
  400.     return 1, 'db already sorted' if $#data <= 0 ;
  401.     if ( $#sortKey < 0 )
  402.       { @data = sort @data ; }
  403.     else
  404.       { &multiSort(*data,*sortKey) ; }
  405.     return 1, 'new jinx db' ;
  406.   }
  407.  
  408. # doProjectData(*data1,*projKey)
  409. # projects @data1 on fields @projKey
  410. sub doProjectData
  411.   { local(*data1,*projKey) = @_ ;
  412.     local($_) ;
  413.  
  414.     for ( @data1 )
  415.       { $_ = join($;,(split(/$;/))[@projKey]) ; }
  416.   }
  417.  
  418. # doProject(*descr1,*name1,*pat1,*data1,*projKey)
  419. # projects a database on fields @projKey
  420. # undates @descr1, @name1, @pat1, @data1
  421. # returns status, some-informative-message
  422. # status == 0 iff @projKey is empty
  423. sub doProject
  424.   { local(*descr1,*name1,*pat1,*data1,*projKey) = @_ ;
  425.     local($_,@tmpName,@tmpPat) ;
  426.  
  427.     return(0,'empty selector ; no change') if $#projKey < 0 ;
  428.  
  429.     @tmpName = @name1 ;
  430.     @tmpPat  = @pat1 ;
  431.     @descr1 = () ;
  432.     @name1 = () ;
  433.     @pat1 = () ;
  434.     for ( @projKey )
  435.       { &addFieldNP(*descr1,*name1,$tmpName[$_],*pat1,$tmpPat[$_]) ; }
  436.  
  437.     &doProjectData(*data1,*projKey) ;
  438.     return(1,'new jinx db') ;
  439.   }
  440.  
  441. # doJoin(*descr1,*data1,*descr2,*data2,$ccNo,$ccMulti)
  442. # joins databases (@descr1,@data1) and (@descr2,@data2)
  443. # $ccNo eq 'A'    : all records in db1 without a companion in db2
  444. #                   are padded with empty data
  445. # $ccNo eq 'D'    : all records in db1 without a companion in db2
  446. #                   are deleted from the join
  447. # $ccMulti eq 'A' : all records in db1 with more than 1 companion in db2
  448. #                   are joined with all companions in db2
  449. # $ccMulti eq 'D' : all records in db1 with more than 1 companion in db2
  450. #                   are deleted from the join
  451. # returns status, some-informative-message
  452. # prints warnings on STDOUT (sorry)
  453. # status == 0 iff db1 and db2 have all or no fields in common
  454. sub doJoin
  455.   { local(*descr1,*data1,*descr2,*data2,$ccNo,$ccMulti) = @_ ;
  456.     local(@name1,@name2) ;
  457.     local(%name1,%name2) ;
  458.     local($name1,$name2) ;
  459.     local(@pat1,@pat2) ;
  460.     local(@joinKey1,@joinKey2,@dataKey2,%dataKey2) ;
  461.     local(@values,$value) ;
  462.     local(@val,$val) ;
  463.     local(@vals,$vals,@nvals) ;
  464.     local(%key,$key) ;
  465.     local(@resDescr,@resName,@resPat,@resData) ;
  466.     local($curr,$i,$_,@errors) ;
  467.  
  468.     &splitDescr(*descr1,*name1,*pat1) ;
  469.     &mkInvert(*name1) ;
  470.     &splitDescr(*descr2,*name2,*pat2) ;
  471.     &mkInvert(*name2) ;
  472.  
  473.     for $name1 (@name1)
  474.       { if ( defined $name2{$name1} )
  475.           { push(@joinKey1,$name1{$name1}) ;
  476.             push(@joinKey2,$name2{$name1}) ;
  477.           }
  478.       }
  479.     for $name2 (@name2)
  480.       { push(@dataKey2,$name2{$name2}) if ! defined $name1{$name2} ; }
  481.     
  482.     return(0,"no fields in common ; no change") if $#joinKey1 < 0 ;
  483.     return(0,"no data to add ; no change")      if $#dataKey2 < 0 ;
  484.  
  485.     $emptyData2 = join($;,&emptyRecord($#dataKey2)) ;
  486.  
  487.     $i = 0 ;
  488.     for $value (@data2)
  489.       { @value = split(/$;/,$value) ;
  490.         $key = join($;,@value[@joinKey2]) ;
  491.         $val = join($;,@value[@dataKey2]) ;
  492.     push(@val,$val) ;
  493.         if ( defined $key{$key} )
  494.           { $key{$key} .= ( ',' . $i++ ) ; }
  495.         else
  496.           { $key{$key} = $i++ ; }
  497.       }
  498.  
  499.     @resDescr = @descr1 ;
  500.     @resName = @name1 ;
  501.     @resPat  = @pat1 ;
  502.     for ( @dataKey2 )
  503.       { &addFieldNP(*resDescr,*resName,$name2[$_],*resPat,$pat2[$_]) ; }
  504.  
  505.     $curr = 0 ;
  506.     for $value (@data1)
  507.       { @value = split(/$;/,$value) ;
  508.         $key = join($;,@value[@joinKey1]) ;
  509.         if ( defined $key{$key} )
  510.           { if ( $key{$key} !~ /,/ )
  511.           { push(@resData, $value . $; . $val[$key{$key}]) ; }
  512.         else
  513.           { @vals = split(/,/,$key{$key}) ;
  514.         if ( $ccMulti !~ /[AD]/ )
  515.           { while (1)
  516.               { &showData(*data1) ;
  517.                 &showStatusBeep($#vals+1 . ' things to join with') ;
  518.                 $ccMulti = &showChoice(*multiKeyMenu,'x') ;
  519.                         if ( $ccMulti eq 's' ) 
  520.                       { ($ccMulti,@nvals) =
  521.                   &selectFrom('join info',*name2,*data2,@vals) ;
  522.                 redo if $ccMulti eq 'x' ;
  523.                     @vals = @nvals ;
  524.                   }
  525.             last ;
  526.               }
  527.           }
  528.         elsif ( ! $inJinx )
  529.                   { print STDERR $#vals+1, " records join with\n" ;
  530.             print STDERR &intext($value), "\n" ;
  531.             for $val ( @vals )
  532.               { print STDERR "$val ", &intext($data2[$val]), "\n" ; }
  533.             print STDERR "added all ", $#vals+1, "\n--------------\n" ;
  534.           }
  535.         if ( $ccMulti eq 'x' )
  536.                   { return(0,'no change') ; }
  537.                 elsif ( $ccMulti =~ /[Aa]/ ) 
  538.               { for $val ( @vals )
  539.               { push(@resData, $value . $; . $val[$val]) ; }
  540.           }
  541.           }
  542.       }
  543.         else
  544.           { if ( $ccNo !~ /[AD]/ )
  545.               { &showStatusBeep("no record to join with") ;
  546.                 &showData(*data1) ;
  547.                 $ccNo = &showChoice(*noKeyMenu,'x') ;
  548.                 return(0,'no change') if $ccNo eq 'x' ;
  549.               }
  550.         elsif ( ! $inJinx )
  551.               { print STDERR "no record joined with\n" ;
  552.         print STDERR &intext($value), "\n" ;
  553.         print STDERR "added empty fields\n--------------\n" ;
  554.           }
  555.             if ( $ccNo =~ /[aA]/ )
  556.               { push(@resData, $value . $; . $emptyData2) ; }
  557.           }
  558.         $curr++ ;
  559.       }
  560.  
  561.     @descr1 = @resDescr ;
  562.     @data1  = @resData ;
  563.  
  564.     return(1,'new jinx db') ;
  565.   }
  566.  
  567. # jinx-private
  568. sub doSelect
  569.   { local(*data,*re,*sub) = @_ ;
  570.     local(@values,@poi,$poi,$i,$re) ;
  571.     for $re ( @re )
  572.       { push(@poi,$i) if $re ne '' ;
  573.         $i++ ;
  574.       }
  575.     return grep( do { @values = split(/$;/,$data[$_],$#re+1) ;
  576.               $i = 0 ;
  577.               grep(/$re[$poi[$i++]]/,@values[@poi]) ;
  578.             }
  579.            , @sub
  580.            ) ;
  581.   }
  582.  
  583. # jinx-private
  584. sub doAddMark
  585.   { local(*data,*re,*marked,*sub) = @_ ;
  586.     local($res,$res1) ;
  587.     return(0,'empty selector ; no change') if grep(/./,@re) == 0 ;
  588.     for $res ( &doSelect(*data,*re,*sub) )
  589.       { $res1++ ; $marked{$res} = 1 ; }
  590.     return 1, $res1 ;
  591.   }
  592.  
  593. # jinx-private
  594. sub doDelMark
  595.   { local(*data,*re,*marked,*sub) = @_ ;
  596.     local($res,$res1) ;
  597.     return(0,'empty selector ; no change') if grep(/./,@re) == 0 ;
  598.     for $res ( &doSelect(*data,*re,*sub) )
  599.       { $res1++ ; delete $marked{$res} ; }
  600.     return 1, $res1 ;
  601.   }
  602.  
  603. # jinx-private
  604. sub doGuessDescr
  605.   { local($num,*newDescr) = @_ ;
  606.     local($i) ;
  607.     @newDescr = () ;
  608.     for ( $i = 1 ; $i <= $num ; $i++ )
  609.       { push(@newDescr,"name$;$i$;field$i") ;
  610.         push(@newDescr,"cpat$;$i$;.*") ;
  611.       }
  612.   }
  613.  
  614. # jinx-private
  615. sub doGuessData
  616.   { local($filename,$sep,*newData) = @_ ;
  617.     local($_,@guess,@rec,$rec,$res) ;
  618.  
  619.     return 0, $@ if ! &testPat($sep) ;
  620.     @newData = () ;
  621.     open(GUESS,$filename) || return 0, "can't open $filename ; no change" ;
  622.     while  ( $_ = <GUESS> )
  623.       { chop ; 
  624.     @rec = split(/$sep/,$_) ;
  625.     $res = &max($res,$#rec) ;
  626.     $rec = join($;,@rec) ;
  627.         $rec =~ s/\t/ /g ;
  628.     push(@newData,$rec) ;
  629.       }
  630.     close(GUESS) ;
  631.     &cleanData(*newData,$res) ;
  632.     return $res+1, 'new db' ;
  633.   }
  634.  
  635. # jinx-private
  636. sub doCompute
  637.   { local(*name,*record,*data,*ddata) = @_ ;
  638.     local($i,$tmp,$expr,$doit,$namelist,$elem,@rec,@hasExpr) ;
  639.     
  640.     $namelist = '($' . join(',$',@name) . ')' ;
  641.  
  642.     $doit = '' ;
  643.     $loop = '' ;
  644.     $loop .= "  { \@main'rec = split(/\$;/,\$main'elem) ;\n" ;
  645.     $loop .= "    $namelist = \@main'rec ;\n" ;
  646.     $i = 0 ;
  647.     for $expr ( @record )
  648.       { if ( $expr )
  649.       { $loop .= "    \$main'tmp = do { $expr ; } ;\n" ;
  650.         $loop .= "    \$main'tmp =~ s/\$;/\\\$;/g ;\n" ;
  651.         $loop .= "    \$main'rec[$i] = \$main'tmp ;\n" ;
  652.         push(@hasExpr,$i) ;
  653.       }
  654.     $i++ ;
  655.       }
  656.     $loop .= "    \$main'elem = join(\$;,\@main'rec) ;\n" ;
  657.     $loop .= "    \$__RECNUM__++ ;\n" ;
  658.     $loop .= "  }\n" ;
  659.     $doit .= "package AAP ;\n" ;
  660.     $doit .= "# reset('a-z') ;\n" ;
  661.     $doit .= "\$__RECNUM__ = 1 ;\n" ;
  662.     $doit .= "for \$main'elem ( \@main'data )\n" ;
  663.     $doit .= $loop ;
  664.     $doit .= "for \$main'elem ( \@main'ddata )\n" ;
  665.     $doit .= $loop ;
  666.     &addlog($doit) ; &curFlush ;
  667.     eval $doit ;
  668.     &addlog('$@: ' . $@) ;
  669.     if ( $@ )
  670.       { $@ = (split(/\n/,$@))[0] ;
  671.         return $@ ;
  672.       }
  673.     return 'new values for ' . join(',',@name[@hasExpr]) ;
  674.   }
  675.  
  676. $namePat = '^\w+$' ;
  677. $COLSdefault = 80 ;
  678. $inJinx = 0 ;
  679.  
  680. 1 ;
  681.